Sound Fx/Sound Fx.iso/Software/UNZIPED/DWSTKW/VB/VB4/PLAY32/PLAYSTK.FRM

Visual Basic Form | 1996-03-24 | 14.4 KB | 455 lines

VERSION 4.00
Begin VB.Form frmMain
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "DiamondWare's Sound ToolKit Demo (Visual Basic 4 Version - 32 bit)"
   ClientHeight    =   3525
   ClientLeft      =   1845
   ClientTop       =   3705
   ClientWidth     =   7020
   Height          =   3930
   Icon            =   "PlaySTK.frx":0000
   Left            =   1785
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3525
   ScaleWidth      =   7020
   ShowInTaskbar   =   0   'False
   Top             =   3360
   Width           =   7140
   Begin VB.CheckBox chkLR
      Caption         =   "Left<->Right"
      Height          =   345
      Left            =   5745
      TabIndex        =   16
      Top             =   705
      Width           =   1245
   End
   Begin VB.OptionButton optRate
      Caption         =   "44,100kHZ"
      Height          =   195
      Index           =   2
      Left            =   5715
      TabIndex        =   12
      Top             =   2820
      Width           =   1410
   End
   Begin VB.OptionButton optRate
      Caption         =   "22,050kHZ"
      Height          =   195
      Index           =   1
      Left            =   5715
      TabIndex        =   11
      Top             =   2460
      Width           =   1410
   End
   Begin VB.OptionButton optRate
      Caption         =   "11,025kHZ"
      Height          =   195
      Index           =   0
      Left            =   5730
      TabIndex        =   10
      Top             =   2085
      Value           =   -1  'True
      Width           =   1410
   End
   Begin VB.CommandButton cmdCommand
      Caption         =   "&Stop"
      Height          =   345
      Index           =   5
      Left            =   2040
      TabIndex        =   9
      Top             =   3075
      Width           =   855
   End
   Begin VB.CommandButton cmdCommand
      Caption         =   "&Remove"
      Height          =   345
      Index           =   2
      Left            =   3000
      TabIndex        =   8
      Top             =   3075
      Width           =   855
   End
   Begin VB.CommandButton cmdCommand
      Caption         =   "&New"
      Height          =   345
      Index           =   0
      Left            =   135
      TabIndex        =   7
      Top             =   3075
      Width           =   840
   End
   Begin VB.VScrollBar vsbModifier
      Height          =   2400
      Index           =   2
      Left            =   5280
      Max             =   16
      Min             =   1
      TabIndex        =   4
      Top             =   600
      Value           =   1
      Width           =   270
   End
   Begin VB.VScrollBar vsbModifier
      Height          =   2400
      Index           =   1
      Left            =   4620
      Max             =   16
      Min             =   1
      TabIndex        =   3
      Top             =   600
      Value           =   1
      Width           =   270
   End
   Begin VB.VScrollBar vsbModifier
      Height          =   2400
      Index           =   0
      Left            =   4200
      Max             =   16
      Min             =   1
      TabIndex        =   2
      Top             =   600
      Value           =   1
      Width           =   270
   End
   Begin VB.CommandButton cmdCommand
      Caption         =   "&Play"
      Height          =   345
      Index           =   1
      Left            =   1095
      TabIndex        =   1
      Top             =   3075
      Width           =   840
   End
   Begin VB.ListBox lstSounds
      Height          =   2385
      IntegralHeight  =   0   'False
      Left            =   75
      TabIndex        =   0
      Top             =   600
      Width           =   3990
   End
   Begin VB.Label lblLabel
      Alignment       =   2  'Center
      Caption         =   "R"
      Height          =   225
      Index           =   3
      Left            =   4620
      TabIndex        =   15
      Top             =   300
      Width           =   240
   End
   Begin VB.Label lblLabel
      Alignment       =   2  'Center
      Caption         =   "L"
      Height          =   225
      Index           =   4
      Left            =   4200
      TabIndex        =   14
      Top             =   300
      Width           =   240
   End
   Begin VB.Label lblLabel
      Alignment       =   2  'Center
      Caption         =   "List of Sounds and Music to Play"
      Height          =   240
      Index           =   2
      Left            =   900
      TabIndex        =   13
      Top             =   180
      Width           =   2595
   End
   Begin VB.Image imgIcon
      Height          =   480
      Left            =   75
      Picture         =   "PlaySTK.frx":030A
      Top             =   75
      Width           =   480
   End
   Begin MSComDlg.CommonDialog dlgFile
      Left            =   6240
      Top             =   60
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Label lblLabel
      Alignment       =   2  'Center
      Caption         =   "Pitch"
      Height          =   225
      Index           =   1
      Left            =   5115
      TabIndex        =   6
      Top             =   3135
      Width           =   600
   End
   Begin VB.Label lblLabel
      Alignment       =   2  'Center
      Caption         =   "Volume"
      Height          =   225
      Index           =   0
      Left            =   4155
      TabIndex        =   5
      Top             =   3120
      Width           =   825
   End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Const I_CMD_LOAD = 0
Const I_CMD_PLAY = 1
Const I_CMD_REMOVE = 2
Const I_CMD_EXIT = 3
Const I_CMD_STOP = 5
Const I_VSB_LVOL = 0
Const I_VSB_RVOL = 1
Const I_VSB_PITCH = 2
Const I_OPT_11K = 0
Const I_OPT_22K = 1
Const I_OPT_44K = 2
Dim miLastSoundNum As Integer
Dim milDir As Integer
Dim mirDir As Integer
Private Sub chkLR_Click()
    dws_DClear
    dws_MClear
    dws_Kill
    If chkLR.Value = False Then
        dws_ID.flags = 0
    Else
        dws_ID.flags = dws_ideal_SWAPLR
    End If
    If dws_Init(dws_DR, dws_ID) = dws_NOSUCCESS Then
        dwsShowError
    End If
End Sub
Private Sub cmdCommand_Click(Index As Integer)
    Dim sString As String
    Dim iIndex As Integer
    Dim iStatus As Integer
    On Error GoTo CCE
    Select Case Index
        Case I_CMD_STOP
            dws_MClear
            dws_DClear

        Case I_CMD_LOAD
            ' Load a default
            dlgFile.FileName = ""
            dlgFile.InitDir = App.Path
            dlgFile.Filter = "Wave, DWD, MIDI Files (*.wav;*.dwd;*.mid)|*.wav;*.dwd;*.mid"
            dlgFile.Action = CD_ACTION_OPEN
            sString = dlgFile.FileName
            If Len(sString) Then
                If InStr(UCase(sString), ".MID") Then
                    lstSounds.AddItem sString
                    lstSounds.ItemData(lstSounds.ListCount - 1) = -1
                ElseIf InStr(UCase(sString), ".WAV") Then
                    iIndex = dwsLoadWave(sString)
                    If iIndex > -1 Then
                        lstSounds.AddItem CStr(gtSI(iIndex).Rate) + ", " + sString
                        lstSounds.ItemData(lstSounds.ListCount - 1) = iIndex
                    End If
                ElseIf InStr(UCase(sString), ".DWD") Then
                    iIndex = dwsLoadWave(sString)
                    If iIndex > -1 Then
                        lstSounds.AddItem CStr(gtSI(iIndex).Rate) + ", " + sString
                        lstSounds.ItemData(lstSounds.ListCount - 1) = iIndex
                    End If
                End If
                lstSounds.ListIndex = (lstSounds.ListCount - 1)
                vsbModifier_Change 0
            End If

        Case I_CMD_PLAY
            If lstSounds.ListIndex > -1 Then
                If lstSounds.ItemData(lstSounds.ListIndex) = -1 Then
                    ' MIDI!
                    Dim tMPlay As dws_MPlay
                    tMPlay.track = lstSounds.List(lstSounds.ListIndex)
                    tMPlay.count = 1
                    iStatus = dws_MPlay(tMPlay)

                    If iStatus = 0 Then
                        dwsShowError
                    End If
                Else
                    dwsPlayWave lstSounds.ItemData(lstSounds.ListIndex), 1
                    miLastSoundNum = gtSI(lstSounds.ItemData(lstSounds.ListIndex)).soundnum
                End If
            End If

        Case I_CMD_REMOVE
            If lstSounds.ListIndex > -1 Then
                If lstSounds.ItemData(lstSounds.ListIndex) > -1 Then
                    ' A Wave!
                    If Not dwsUnloadWave(lstSounds.ItemData(lstSounds.ListIndex)) Then
                        MsgBox "Error unloading Wave File!"
                    End If
                End If

                lstSounds.RemoveItem lstSounds.ListIndex

            End If

        Case Else
    End Select
CCER:
    Exit Sub
    MsgBox "Error '" + Error + "' occurred in FRMMAIN:cmdCommand_Click!"
    Resume CCER
End Sub
Private Sub Form_Load()
    ' Center the form!
    Dim sString As String
    Dim lResult As Long
    ReDim gtSI(0) As SoundInfo
    Me.Move (Screen.Width / 2) - (Me.Width / 2), (Screen.Height / 2) - (Me.Height / 2)
    If dws_DetectHardWare(dws_DR) = dws_NOSUCCESS Then
        dwsShowError
        End
    End If
    ' No sound card (or something that's weird)
    If dws_DR.digcaps = 0 Then
        MsgBox "Your computer does not support sound playback.", vbExclamation, "Sound Toolkit Error"
        End
    End If
    ' Does the sound card support the minimum requirements?
    If (dws_DR.digcaps And dws_digcap_11025_08_2) = False Then
        sString = "DiamondWare's Sound ToolKit for Windows supports sound playback on your computer.  "
        sString = sString + "However, this demo requires 8-bit stereo "
        sString = sString + "which your computer does not support.  "
        sString = sString + "Your sound hardware does not support "
        sString = sString + "11025Hz, two channel, 8 bit sound "
        sString = sString + "This demo will not run properly on your computer."

        MsgBox sString, vbExclamation, "Sound Toolkit Error"
        End
    End If

    ' Detect and select the best MIDI deivce to use!
    If dws_DR.muscaps And dws_muscap_MAPPER Then
        lResult = dws_muscap_MAPPER
    ElseIf dws_DR.muscaps And dws_muscap_FMSYNTH Then
        lResult = dws_muscap_FMSYNTH
    ElseIf dws_DR.muscaps And dws_muscap_SYNTH Then
        lResult = dws_muscap_SYNTH
    ElseIf dws_DR.muscaps And dws_muscap_SQSYNTH Then
        lResult = dws_muscap_SQSYNTH
    ElseIf dws_DR.muscaps And dws_muscap_MIDIPORT Then
        lResult = dws_muscap_MIDIPORT
    End If
    ' Set up the 'ideal' music type!
    dws_ID.mustyp = lResult
    dws_ID.digtyp = dws_digcap_11025_08_2
    dws_ID.dignvoices = 6
    If dws_Init(dws_DR, dws_ID) = dws_NOSUCCESS Then
        dwsShowError
    End If
    vsbModifier(I_VSB_LVOL).Value = 8
    vsbModifier(I_VSB_RVOL).Value = 8
    vsbModifier(I_VSB_PITCH).Value = 8
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim iLoop As Integer
    dws_DClear
    dws_MClear
    ' Unload all loaded wave files!
    If giNumSounds > 0 Then
        For iLoop = 0 To UBound(gtSI)
            dwsUnloadWave iLoop
        Next iLoop
    End If
    If dws_Kill() = dws_NOSUCCESS Then
        dwsShowError
    End If
End Sub
Private Sub lstSounds_DblClick()
    cmdCommand_Click (I_CMD_PLAY)
End Sub
Private Sub optRate_Click(Index As Integer)
    dws_DClear
    dws_MClear
    dws_Kill
    Select Case Index
        Case I_OPT_11K
            dws_ID.digtyp = dws_digcap_11025_08_2
        Case I_OPT_22K
            dws_ID.digtyp = dws_digcap_22050_08_2
        Case I_OPT_44K
            dws_ID.digtyp = dws_digcap_44100_08_2
        Case Else
    End Select
    If dws_Init(dws_DR, dws_ID) = dws_NOSUCCESS Then
        dwsShowError
    End If
End Sub
Private Sub vsbModifier_Change(Index As Integer)
    Dim iStatus As Integer
    Dim iValue As Integer
    Dim iValue2 As Integer
    Dim iIndex As Integer
    ' Are we changing the volume of a WAVE or MIDI?
    If lstSounds.ListIndex > -1 Then
        If lstSounds.ItemData(lstSounds.ListIndex) = -1 Then
             ' It's a MIDI!
            iValue = ((16 - vsbModifier(I_VSB_LVOL).Value) * 16) - 1
            iValue2 = ((16 - vsbModifier(I_VSB_RVOL).Value) * 16) - 1
            'dws_XMusic iValue, iValue2
            Exit Sub
        End If
    End If
    ' Assign the Sound Num
    If lstSounds.ListIndex = -1 Then
        gPlay.soundnum = 0
    Else
        iIndex = lstSounds.ItemData(lstSounds.ListIndex)
        gPlay.soundnum = gtSI(iIndex).soundnum
    End If

    ' Get the current play information associated
    ' with the sound num.
    dws_DGetInfo gPlay, ByVal 0&

    ' Adjsut the value
    Select Case Index
        Case I_VSB_PITCH
            iValue = vsbModifier(Index).Value
        Case Else
            iValue = (16 - vsbModifier(Index).Value)
    End Select
    If iValue >= 8 Then
        iValue = (iValue - 7) * 256
    Else
        iValue = iValue * 32
    End If
    Select Case Index
        Case I_VSB_LVOL
            gPlay.flags = dws_dplay_LVOL
            gPlay.lvol = iValue

        Case I_VSB_RVOL
            gPlay.flags = dws_dplay_RVOL
            gPlay.rvol = iValue

        Case I_VSB_PITCH
            gPlay.flags = dws_dplay_PITCH
            gPlay.pitch = iValue

        Case Else
    End Select
    If lstSounds.ListIndex = -1 Then
        gPlay.soundnum = 0
    Else
        gPlay.soundnum = gtSI(iIndex).soundnum
    End If
    ' Assign the new Play Information
    dws_DSetInfo gPlay, ByVal 0&
End Sub
Private Sub vsbModifier_Scroll(Index As Integer)
    vsbModifier_Change Index
End Sub